home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / PROLOG / HUMBOLT / HUMBOLTS / _files / _humboltsr / SYMBOL._c < prev    next >
Text File  |  1990-06-10  |  12KB  |  421 lines
  1. /***************************************************
  2. ****************************************************
  3. **                                                **
  4. **  HU-Prolog     Portable Interpreter System     ** 
  5. **                                                **
  6. **  Release 1.62   January  1990                  **
  7. **                                                **
  8. **  Authors:      C.Horn, M.Dziadzka, M.Horn      **
  9. **                                                **
  10. **  (C) 1988      Humboldt-University             **
  11. **                Department of Mathematics       **
  12. **                GDR 1086 Berlin, P.O.Box 1297   **
  13. **                                                **
  14. ****************************************************
  15. ***************************************************/
  16.  
  17.  
  18. #include "systems.h"
  19. #include "types.h"
  20. #include "errors.h"
  21. #include "atoms.h"
  22.  
  23. #if SYMBOLARITH
  24.  
  25. IMPORT boolean REDUCEFLAG;
  26. IMPORT void ABORT();
  27. IMPORT boolean DOREDUCE();
  28. IMPORT ATOM modify();
  29. IMPORT ATOM LOOKATOM();
  30. IMPORT void WRITEOUT();
  31. extern TERM substsim();
  32.  
  33. #if DEBUG
  34. #define test(p,t)  if(DEBUGFLAG) \
  35.                {ws("[");wi(E);ws("]");ws(p); \
  36.                 WRITEOUT(t,false);ws("\n");}
  37. #endif
  38. #if ! DEBUG
  39. #define test(p,t)
  40. #endif
  41.  
  42. LOCAL TERM MAC_HLP;
  43. #define symbred(X)   psymbred(X)
  44. /*
  45. #define symbred(X)   (name(MAC_HLP=X) < NORMATOM ? MAC_HLP : \
  46.                         psymbred(X))
  47.  
  48. */
  49. LOCAL TERM mkl1(ATOM AT1, TERM S1)
  50. {   TERM H,H1;
  51.     H1=H=stackterms(2);
  52.                  name(H1)=AT1;son(H1)=S1;
  53.     next_br(H1); name(H1)=nil_atom;son(H1)=nil_term; 
  54.     return H;
  55. }
  56.  
  57. LOCAL TERM mkl2(ATOM AT1, TERM S1, ATOM AT2, TERM S2)
  58. {   register TERM H,H1;
  59.     H1=H=stackterms(3);
  60.                  name(H1)=AT1; son(H1)=S1;
  61.     next_br(H1); name(H1)=AT2; son(H1)=S2;
  62.     next_br(H1); name(H1)=nil_atom; son(H1)=nil_term;
  63.     return H;
  64. }
  65.  
  66. LOCAL TERM mkl3(ATOM AT1, TERM S1, ATOM AT2, TERM S2, ATOM AT3, 
  67.                 TERM S3)
  68. {   register TERM H,H1;
  69.     H1=H=stackterms(4);
  70.                  name(H1)=AT1; son(H1)=S1;
  71.     next_br(H1); name(H1)=AT2; son(H1)=S2;
  72.     next_br(H1); name(H1)=AT3; son(H1)=S3;
  73.     next_br(H1); name(H1)=nil_atom; son(H1)=nil_term;
  74.     return H;
  75. }
  76.  
  77. LOCAL boolean gbproc(ATOM *A, TERM *T)
  78. { if(name(*T)!=COLON_2)return 1;
  79.   *A=name(arg1(*T));
  80.   if(arity(*A)||(*A)<NORMATOM)return 1;
  81.   *T=arg2(*T);
  82.   return 0;
  83. }
  84.  
  85. #define getbound(NNN,HHH)    if(gbproc(&NNN,&HHH))goto fret;else
  86. #define check2(HHH,CCC)    if(CCC){HHH=symbred(HHH);if(CCC)goto eret;}else
  87.  
  88. TERM psymbred(TERM H)
  89.   { TERM H1,H2;
  90.     ATOM N,N1,N2;
  91.     deref(H);
  92.     N=name(H);
  93.     switch(N)
  94.     {
  95.       case INTT:
  96.       case UNBOUNDT:
  97.            goto fret;
  98.       case RECIND_3:
  99.            H1=arg1(H);
  100.        check2(H1,name(H1)!=INL_1 && name(H1)!=INR_1);
  101.            if(name(H1)==INL_1)
  102.            { H2=arg2(H);
  103.          getbound(N1,H2);
  104.              H=symbred(substsim(H2,mkl1(N1,arg1(H1))));
  105.              goto fret;
  106.            }
  107.            if(name(H1)==INR_1)
  108.            { TERM T;
  109.              H2=arg3(H);
  110.          getbound(N1,H2);
  111.          getbound(N2,H2);
  112.              T=stackterms(3);
  113.              name(T)=N1; son(T)=nil_term; 
  114.              name(br(T))=COLON_2; son(br(T))=son(arg2(H));
  115.              name(br(br(T)))=COLON_2; son(br(br(T)))=son(arg3(H));
  116.              H=substsim(H2, mkl2(N1,mkfunc(LAMBDA_1,
  117.                mkfunc(COLON_2,mk2sons(N1,nil_term,RECIND_3,T))),
  118.                                   N2,arg1(H1)));
  119.              goto fret;
  120.            }
  121.       case QUOTE_1:
  122.            H=arg1(H); goto fret;
  123.       case EVAL_1:
  124.            H=symbred(psymbred(arg1(H))); goto fret;
  125.       case OF_2: 
  126.            H1=arg1(H); 
  127.        check2(H1,name(H1)!=LAMBDA_1);
  128.        H1=arg1(H1);
  129.        getbound(N1,H1);
  130.        H=substsim(H1,mkl1(N1,symbred(arg2(H))));
  131.        goto eret;
  132.       case SPREAD_2:
  133.              H1=arg1(H);
  134.          check2(H1,name(H1)!=COMMA_2);
  135.              H2=arg2(H);
  136.          getbound(N1,H2);
  137.          getbound(N2,H2);
  138.              H=substsim(H2,mkl2(N1,arg1(H1),N2,arg2(H1)));
  139.              goto eret;
  140.      case DECIDE_3:
  141.            H1=arg1(H);
  142.        check2(H1,name(H1)!=INL_1 && name(H1)!=INR_1);
  143.            if(name(H1)==INL_1)H2=arg2(H);
  144.            else H2=arg3(H);
  145.        getbound(N1,H2);
  146.            H=substsim(H2,mkl1(N1,arg1(H1)));
  147.            goto eret;
  148.     case COMMA_2:
  149.     case CONS_2:
  150.            H=mkfunc(N,mk2sons(VART,symbred(arg1(H)),VART,symbred(arg2(H))));
  151.            goto fret;
  152.     case LAMBDA_1:
  153.     case NIL_0: goto fret;
  154.     case SUCC_1:
  155.        H=symbred(arg1(H));
  156.        if (name(H)==PRED_1) H=arg1(H); 
  157.        /* else if (name(H)==INTT) H=mkint(ival(H)+1); */
  158.            else H=mkfunc(SUCC_1,mkfunc(VART,H));
  159.        goto fret;
  160.     case PRED_1:
  161.        H=symbred(arg1(H));
  162.        if (name(H)==SUCC_1) H=arg1(H); 
  163.        /* else if (name(H)==INTT) H=mkint(ival(H)-1); */
  164.            else H=mkfunc(PRED_1,mkfunc(VART,H));
  165.        goto fret;
  166.     case INL_1:
  167.     case INR_1:
  168.            H=mkfunc(N,mkfunc(VART,symbred(arg1(H))));
  169.            goto fret;
  170.     case INT_EQ_4:
  171.       { TERM L,R,T;
  172.     L=symbred(arg1(H)); R=symbred(arg2(H));
  173.     if (name(L)==INTT && name(R)==INTT)
  174.     { if (ival(L)==ival(R)) H=symbred(arg3(H)); 
  175.       else H=symbred(arg4(H));
  176.       goto eret;
  177.     }
  178.     T=H1=stackterms(4);
  179.     name(H1)=VART; val(H1)=L; next_br(H1);
  180.     name(H1)=VART; val(H1)=R; next_br(H1);
  181.     name(H1)=VART; val(H1)=arg3(H); next_br(H1);
  182.     name(H1)=VART; val(H1)=arg4(H); 
  183.         H=mkfunc(N,T);
  184.     goto fret;
  185.       }
  186.     case IND_4:
  187.       { ATOM LAST,I;
  188.         TERM desc;
  189.         int n, ii, sign;
  190.            H1=arg1(H);
  191.        check2(H1,name(H1)!=INTT);
  192.            ii=ival(H1);
  193.            if(ii==0) { H=symbred(arg3(H)); goto fret; }
  194.            if(ii<0){ desc=arg2(H); sign= -1; }
  195.            else { desc=arg4(H); sign=1; }
  196.        getbound(I,desc);
  197.        getbound(LAST,desc);
  198.            H=arg3(H);
  199.            H2=mkint(98);
  200.            for(n=1;n<=ii;n +=sign)
  201.             {
  202.              ival(H2)=n;
  203.              H=substsim(desc,mkl2(LAST,H,I,H2));
  204.              if(name(H) > NORMATOM && DOREDUCE(H1=mkfreevar(),H,true))
  205.                     {H=H1;deref(H);}
  206.             }
  207.            goto fret;
  208.            break;
  209.       }
  210.  
  211.      case PIND_3:
  212.       { TERM ST,HH;
  213.     H1=arg1(H); 
  214.         if(name(H1)==INTT)
  215.       if (ival(H1)==0) { H=arg2(H); goto fret; }
  216.       else if (ival(H1)<0) goto fret;
  217.       else { }
  218.         if(name(H1)!=SUCC_1) 
  219.         {
  220.           H1=symbred(H1);
  221.       if(name(H1)==INTT) 
  222.         if (ival(H1)==0) { H=arg2(H); goto fret;}
  223.         else if (ival(H1)<0) goto fret;
  224.         else { }
  225.           if(name(H1)!=SUCC_1)goto fret;
  226.         } 
  227.         H2=arg3(H);
  228.     getbound(N1,H2);
  229.     getbound(N2,H2);
  230.         HH=ST=stackterms(1);
  231.         while(name(H1)==SUCC_1)
  232.           { H1=arg1(H1); son(ST)=H1; ST=stackterms(1); }
  233.         dec_term(ST);
  234.     if(name(H1)==INTT && ival(H1)==0)  H=arg2(H); 
  235.         else
  236.          { TERM T;/*  fehler!!!!! */
  237.           T=stackterms(3);
  238.           name(T)=name(br(T))=name(br(br(T)))=VART;
  239.           son(T)=H1; son(br(T))=arg2(H);
  240.           son(br(br(T)))=arg3(H);
  241.           H=mkfunc(PIND_3,T); 
  242.          }
  243.         while(ST >=HH)
  244.         {
  245.           H=substsim(H2,mkl2(N1,son(ST),  /* predecessor */
  246.                               N2,H)              /* rec.value */
  247.                      );
  248.           dec_term(ST);
  249.         }
  250.         goto eret;
  251.        }
  252.      case LISTIND_3:
  253.       {ATOM N3;
  254.        TERM ST,HH;
  255.         H1=arg1(H);
  256.         if(name(H1)==NIL_0) 
  257.            { H=arg2(H); goto fret;}
  258.         if(name(H1)!=CONS_2)
  259.         {
  260.           H1=symbred(H1);
  261.       if(name(H1)==NIL_0){H=arg2(H);goto fret;}
  262.           if(name(H1)!=CONS_2)goto fret;
  263.         }
  264.         H2=arg3(H);
  265.     getbound(N1,H2);
  266.     getbound(N2,H2);
  267.     getbound(N3,H2);
  268.         HH=ST=stackterms(1);
  269.         while(name(H1)==CONS_2)
  270.         {
  271.           son(ST)=H1;
  272.           H1=arg2(H1); ST=stackterms(1);
  273.         }
  274.         dec_term(ST);
  275.         if(name(H1)==NIL_0)H=arg2(H);
  276.         else
  277.          { TERM T;/*  fehler!!!!! */
  278.           T=stackterms(3);
  279.           name(T)=name(br(T))=name(br(br(T)))=VART;
  280.           son(T)=H1; son(br(T))=arg2(H);
  281.           son(br(br(T)))=arg3(H);
  282.           H=mkfunc(LISTIND_3,T);
  283.          }
  284.         while(ST >=HH)
  285.         {
  286.           H=substsim(H2,mkl3(N1,arg1(son(ST)),  /* list head */
  287.                               N2,arg2(son(ST)),  /* list rest */
  288.                               N3,H)              /* rec.value */
  289.                      );
  290.           dec_term(ST);
  291.         }
  292.         goto eret;
  293.        }
  294.      default:
  295.            if(arity(N)==0)
  296.            { N1=LOOKATOM(N,1);
  297.             if(clause(N1) && !name(body(clause(N1))))
  298.              { H=mkfreevar();
  299.                UNI(H,son(head(clause(N1))));
  300.                deref(H); goto fret;
  301.              }
  302.            }
  303.     }
  304. eret:
  305.   H1=mkfreevar();
  306.   if(name(H) > NORMATOM && DOREDUCE(H1,H,true))
  307.       {H=H1; deref(H);}
  308. fret:
  309.   return H;
  310. }
  311.  
  312. GLOBAL boolean appears(ATOM A, int N, TERM T)
  313. { register TERM X;
  314.   register ATOM AA;
  315.   while(N-->0)
  316.   { X=T; deref(X); 
  317.     if((AA=name(X))==A) return true;
  318.     if(AA==COLON_2 && name(arg1(X))==A) return false;
  319.     if(AA>NORMATOM && arity(AA))
  320.       if(appears(A,arity(AA),son(X))) return true;
  321.     next_br(T);
  322.   }
  323.   return false;
  324. }
  325.  
  326. TERM substsim(TERM T, TERM L)
  327. /* short list */
  328. { register TERM H,H1;
  329.   int I;
  330.   register TERM HL;
  331.   ATOM N,NN;
  332.    deref(T);
  333.    if(!name(L)){H=T;goto ende;}
  334.    if((N=name(T)) < NORMATOM) return T;
  335.    if(arity(N)==0) 
  336.      {   HL=L;
  337.          while(name(HL))
  338.            {
  339.              if(name(HL) !=N) next_br(HL);
  340.              else
  341.                { H=mkfunc(VART,son(HL));
  342.                  goto ende;
  343.                }
  344.            }
  345.          H=  T; goto ende;
  346.      }
  347.    if(N==COLON_2)
  348.      { ATOM N0; TERM LL;
  349.        if((N=name(arg1(T))) > NORMATOM && arity(N)==0)
  350.        { if (N!=TILDE_0)
  351.       { LL=L; NN=N;
  352.         next_atom:
  353.         while(N0=name(LL))
  354.         { while(N==N0 || appears(N,1,son(LL))) 
  355.                     { N=modify(N); LL=L; goto next_atom; }
  356.           next_br(LL);
  357.         }
  358.           }
  359.      if(N!=NN &&  N!=TILDE_0) /* renaming NN --> N */
  360.         T=substsim(arg2(T),mkl1(NN,mkatom(N)));
  361.      else T=arg2(T);
  362.      T=mkfunc(COLON_2,mk2sons(N,nil_term,VART,substsim(T,L)));
  363.          return T;
  364.        }
  365.        N=COLON_2;
  366.      }
  367.    T=son(T); H=H1=stackterms(arity(N));
  368.    I=arity(N);
  369.    for(;;)
  370.     { ATOM A;
  371.       register TERM TT;
  372.       TT=T; deref(TT);
  373.       if((A=name(TT))<NORMATOM){ name(H1)=VART;son(H1)=TT;goto cont;}
  374.       if(arity(A)==0) 
  375.          {   HL=L;
  376.              while(non_nil_atom(name(HL)))
  377.                {
  378.                  if(name(HL)!=A) HL=br(HL);
  379.                  else
  380.                    { name(H1)=VART;
  381.                      son(H1)=son(HL);
  382.                      goto cont;
  383.                    }
  384.                }
  385.              name(H1)=A; son(H1)=nil_term;
  386.              goto cont;
  387.          }
  388.       else {name(H1)=VART; son(H1)=substsim(TT,L);}
  389. cont:
  390.       if(--I==0) break;
  391.       next_br(H1);next_br(T); 
  392.     }
  393.    H=mkfunc(N,H);
  394. ende:
  395.    deref(H);
  396.    if (!REDUCEFLAG) goto ret;
  397.    N=name(H); if(arity(N)) NN=name(arg1(H)); 
  398.    if(N==LISTIND_3 && (NN==CONS_2 || NN==NIL_0)) goto redret;
  399.    if(N==PIND_3 && (NN==SUCC_1 || NN==INTT)) goto redret;
  400.    if(N==IND_4 && NN==INTT) goto redret;
  401.    if(N==INT_EQ_4 && NN==INTT && name(arg2(H))==INTT) goto redret;
  402.    /* !!!!!! pfui !!!!!!! */
  403.    if(N==OF_2 && name(symbred(arg1(H)))==LAMBDA_1) goto redret;
  404.    if(N==SPREAD_2 && NN==COMMA_2) goto redret;
  405.    if(N==DECIDE_3 && (NN==INL_1 || NN==INR_1)) goto redret;
  406.    if(N==RECIND_3 && (NN==INL_1 || NN==INR_1)) goto redret;
  407.    if(N==EVAL_1 || N==QUOTE_1) goto redret;
  408.   H1=mkfreevar();
  409.   if(name(H) > NORMATOM && DOREDUCE(H1,H,true))
  410.       {H=H1; deref(H);}
  411.    goto ret;
  412. redret: 
  413.    H=symbred(H);
  414. ret:
  415.    return H;
  416. }
  417.  
  418. #endif
  419.  
  420.  
  421.